perm filename GEOMED[G,BGB]3 blob
sn#054438 filedate 1973-07-24 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00028 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00004 00002 TITLE GEOMED - GEOMETRIC EDITOR - BGB - JANUARY 1973.
C00006 00003 EDITOR STATUS.
C00009 00004 START ADDRESS INITIALIZATION-------------------------------------
C00011 00005 ASCII 00 TO 37--------------------------------------------------
C00014 00006 ASCII 40 TO 100-------------------------------------------------
C00017 00007 ASCII 101 TO 132 UPPER CASE-------------------------------------
C00020 00008 SUBR(VBODY) MAKE VERTEX BODY.
C00044 00009 SUBR(MIDPOI) MIDPOINT AN EDGE PROPORTIONAL TO DDEL
C00048 00010 SUBR(EUTRAN)
C00052 00011 ----- EUTRAN MAKE REFERENCE FRAME.
C00056 00012 SWITCH COMMANDS.
C00058 00013 STACK MODIFYING COMMANDS. "↔↓↑"
C00060 00014 STRENGTH COMMANDS.
C00064 00015 SUBR(XSWEEP)
C00067 00016 SUBR XKILL "K"
C00069 00017 SUBR LINKER LINK FOLLOWING COMANDS.
C00071 00018 ----- LINKER OTHER LINK COMMANDS.
C00074 00019 COMMANDS XNAME,XBODY "B","N"
C00076 00020 SUBR RDNAME
C00078 00021 SUBR(INSTANT)
C00080 00022 XDPY:
C00083 00023 XBIN:
C00085 00024 SUBR(NEWMAC)
C00089 00025 XTEXT: TEXT COMMAND.
C00091 00026 SUBR(EXTEND): "X"-EXTEND COMMANDS.
C00093 00027 XCUBE: MAKE CUBIC PRISM. "X-CUB".
C00094 00028 SUBR(XCOLOR) COLORING X-COMMAND.
C00099 ENDMK
C⊗;
TITLE GEOMED - GEOMETRIC EDITOR - BGB - JANUARY 1973.
SUBR GEOMED ;TELETYPE COMMAND JUMP TABLE
;____________________________________________________________________
L0: CRLF
L1: OUTCHR["*"] ;GEOMED'S EAR TOP LEVEL.
L2: CALL(STADPY) ;STATUS DISPLAY.
LAC ALPHA↔DAC CTRL↔SETZM ALPHA
LAC BETA ↔DAC META↔SETZM BETA
CALL(GETCW0)
TRZE 200↔SETOM CTRL ;CONTROL-KEY FLAG.
TRZE 400↔SETOM META ;META-KEY FLAG.
CAIN 0,15↔GO[SETZM ITERAT↔GO L2];CARRIAGE RETURN.
CAIN 0,12↔GO L1 ;LINE-FEED.
DAC 0,CHR
LAC CTRL↔AND META↔DAC MTCT ;META-CONTROL FLAG.
SETZ↔SKIPE CTRL↔IORI 1
SKIPE META↔IORI 2↔DAC MCBITS ;META-CONTROL BITS.
;READ JUMP TABLE.
LAC CHR↔DAC 1
CAIG 0,140↔GO[CAR 1,A00(1)↔GO L3]
CAIG 0,172↔GO[CAR 1,A00-40(1)↔GO L3]
CAR 1,A173-173(1)
L3: PUSHJ P,(1) ;CALL GEOMED COMMAND CHARACTER SUBR.
GO L2 ;NO-SKIP IMMEDIATE COMMAND.
GO L0 ;SKIP CRLF-STAR COMMAND.
LIT
ENDR GEOMED;2/4/73(BGB)
NOP: OUTCHR CHR↔OUTSTR[ASCIZ/ NO OPERATION./]↔CRLF↔POP0J
QMARK: CALL(GETCW0)↔DAC 1
CAIG 0,140↔GO[CDR 1,A00(1)↔GO L4]
CAIG 0,172↔GO[CDR 1,A00-40(1)↔GO L4]
CDR 1,A173-173(1)
L4: CRLF↔OUTCHR[" "]
OUTSTR(1) ;PRINT GEOMED COMMAND CHARACTER COMMENT.
CRLF↔OUTCHR["*"]↔POP0J
;EDITOR STATUS.
PDL↑: BLOCK =300 ;GEOMED'S INTERNAL STACK.
PAT↑: BLOCK 40
PDLPTR: XWD -100,PADPDL ;GEOMED'S GRAPHICS STACK.
PADPDL: BLOCK 100
↓PTR←←16 ;PADPDL STACK POINTER AC.
;JUMP TABLE COMMAND SCANNER STATUS.
DECLARE{CHR,MCBITS,CTRL,META,MTCT,ALPHA,BETA}
;STRENGTH OF EUCLIDEAN TRANSFORMATION.
TDEL: 1.0 ;TRANSLATION DELTA STRENGTH.
RDEL: 0.785398;ROTATION DELTA STRENGTH.
DDEL: 0↔0.75 ;DILATION DELTA STRENGTH.
OPERAT: 0 ;DEFAULT EUCLIDEAN OPERATION.
FRAAM: 0 ;FRAME OF REFERENCE.
FRMORG: 0 ;USE FRAME OF REFERENCE ORIGIN.
AXECNT: 1 ;NUMBER OF AXES TO USE.
ITERAT: 0 ;NUMBER OF ITERATIONS.
FLAGL: -1 ;"L" COMMAND SWITCH. LABEL LIGHTS.
FLAGD: 0 ;"∂" NODE DISPLAY.
FLAGSD: -1 ;"≡" STATUS DISPLAY.
DPYFLG↑:2 ;GEODPY STICKY DISPLAY MODE.
ODPYFLG: 2 ;OLD GEODPY STICKY DISPLAY MODE.
DDSTA: 0 ;DD CHANNEL FOR STATUS
DDGEO: 0 ;DD CHANNEL FOR POLYGON DISPLAY
;IO OPERATIONS
EXTERN GETCHW ;GET A CHARACTER (IN CHARACTER MODE FOR TTY)
EXTERN GETCHL ;GET A CHARACTER (IN LINE MODE FOR TTY)
EXTERN GETCL0,GETCW0 ;SAME EXCEPT RETURNS RESULT IN 0 INSTEAD 1.
;WING OPERATIONS.
EXTERN MKB,MKF,MKE,MKV,MKFRAME
EXTERN KLB,KLF,KLE,KLV,WING
EXTERN WING,LINKED
EXTERN ECW,ECCW,OTHER,OTHER.
EXTERN BGET,FCW,FCCW,VCW,VCCW
;EULER OPERATIONS.
EXTERN MKEV,MKFE
INTERN CAMERA↔CAMERA:0
WORLD:0
WINDOW:0
EXTERN KLNODE,UNIVER,OLD44,AVAIL
;START ADDRESS INITIALIZATION-------------------------------------
EXTERN GEODPY
SA: JFCL↔SETOM ALONE#
SKIPE 1,OLD44↔CORE 1,↔JFCL↔SETZM OLD44
SKIPA 17,[IOWD =300,PDL]
GEONIT: SETZM ALONE↔INTERN GEONIT ;GEOMETRIC MODEL INIT.
;CREATE A GEOMED UNIVERSE.
SETZB AVAIL ;...SO THAT @AVAIL IS ZERO.
CALL(MKUNIV↑)
;SETUP STRENGTH OF TRANSFORMATION VALUES.
LAC[1.0]↔DAC TDEL ;TRANSLATION STRENGTH.
LAC[0.75]↔DAC DDEL ;DILATION STRENGTH.
LAC[0.785398]↔DAC RDEL ;ROTATION STRENGTH π/4.
SETZM FRAAM ;SELECT WORLD FRAME.
SETZM FRMORG
SETOM FLAGL ;TURN ON THE LIGHTS.
LACI 1↔DAC AXECNT ;ONE AXIS SELECT.
SETZM OPERAT ;TRANSLATION DEFAULT.
LAC[XWD -100,PADPDL]↔DAC PDLPTR
SKIPN ALONE↔POP0J
;RE-ENTRY ADDRESS INITIALIZATION----------------------------------
REE: LACI .↔DAC 124
LAC 17,[IOWD =300,PDL]
OPDEF PPIOT[702B8]
OUTCHR[14]↔PGIOT 2, ;CLEAR PIECES OF GLASS
PPIOT 2,-=250↔PPIOT 3,3003
PUSHJ P,[GO TRAPINIT↑]
CALL(GEODPY)
CALL(GEOMED)
CALLI 12
;2/4/73-----------------------------------------------------------
;ASCII 00 TO 37--------------------------------------------------
DEFINE $$(Q,A,B){XWD A,[ASCIZ"B"]}
A00: NOP ;null.
$$("↓",PADPSH,{ ↓ COPY PUSH. α↓ ROTATE PUSH.})
$$("α",{[SETOM ALPHA↔POP0J]},{α CONTROL KEY PREFIX.})
$$("β",{[SETOM BETA↔POP0J]},{β META KEY PREFIX.})
$$("∧",LINKER,{ ∧ FETCH PVT LINK})
$$("¬",XEVERT,{ ¬ BODY EVERT. α¬ BODY SUBTRACTION.})
$$("ε",{[SETOM ALPHA↔SETOM BETA↔POP0J]},{ε META-CONTROL PREFIX.})
$$("π",XRDEL,{ π ACCEPT ROTATION DELTA.})
$$("λ",XTDEL,{ λ ACCEPT TRANSLATION DELTA.})
$$(" ",NOP,{ TAB.})
$$(" ",NOP,{ LF.})
$$(" ",NOP,{ VT.})
$$(" ",NOP,{ FF.})
$$(" ",NOP,{ CR.})
$$("∞",INSTANT,{ ∞ INSTANT CUBE. α∞ INSTANT TORUS.})
$$("∂",SWCD,{ ∂ FLIP NODE DISPLAY SWITCH.})
$$("⊂",LINKER,{ ⊂ FETCH BRO LINK.})
$$("⊃",LINKER,{ ⊃ FETCH SIS LINK.})
$$("∩",LINKER,{ ∩ FETCH DAD LINK, α∩ BODY INTERSECTION.})
$$("∪",LINKER,{ ∪ FETCH SON LINK, α∪ BODY UNION.})
$$("∀",XDISBL,{ ∀ DISABLE BODY OPERATIONS SWITCH.})
$$("∃",SWC4,{ ∃ REFLECTION DEFAULT.})
$$("⊗",LINKER,{ ⊗ FETCH UNIVERSE NODE.})
$$("↔",PADSWP,{(1ST ↔ 2ND)(1ST α↔ 3RD)(1ST β↔ LAST)(2ND ε↔ 3RD)})
$$("_",XDPY,{ _ STICKY DISPLAY MODE SWITCH.})
$$("→",LINKER,{ → FETCH ALT2 LINK.})
$$("~",NOP,{ TILDE})
$$("≠",NOP,{ ≠})
$$("≤",LINKER,{ ≤ FETCH NED LINK.})
$$("≥",LINKER,{ ≥ FETCH PED LINK.})
$$("≡",SWCSD,{ ≡ TOGGLE STATUS DISPLAY.})
$$("∨",LINKER,{ ∨ FETCH NVT LINK.})
;----------------------------------------------------------------
;ASCII 40 TO 100-------------------------------------------------
$$(" ",XREDPY,{ SPACE})
$$("!",SWC1,{ ! TRANSLATION DEFAULT SWITCH.})
$$(" ",NOP,{ DOUBLE QUOTE.})
$$("#",CRLF20,{ # TWENTY CRLF'S.})
$$("$",XCONVEX,{ MAKE CONVEX.})
$$("%",XDDEL,{ % SET DILATION DELTA STRENGTH.})
$$("&",NOP,{ &})
$$("'",NOP,{ '})
$$("(",EUTRAN,{ EUCLIDEAN TRANSFORMATION -Y.})
$$(" ",EUTRAN,{ EUCLIDEAN TRANSFORMATION +Y.})
$$("*",EUTRAN,{ EUCLIDEAN TRANSFORMATION +Z.})
$$("+",LINKER,{ OTHER LINK.})
$$(" ",LINKER,{ CLOCKWISE LINK.})
$$("-",EUTRAN,{ EUCLIDEAN TRANSFORMATION -Z.})
$$(".",LINKER,{ COUNTER CLOCKWISE LINK.})
$$("/",HALVE ,{ HALVE STRENGTH.})
$$("0",SETDIG,{ SET-DIGIT COMMAND.})
$$("1",SETDIG,{ SET-DIGIT COMMAND.})
$$("2",SETDIG,{ SET-DIGIT COMMAND.})
$$("3",SETDIG,{ SET-DIGIT COMMAND.})
$$("4",SETDIG,{ SET-DIGIT COMMAND.})
$$("5",SETDIG,{ SET-DIGIT COMMAND.})
$$("6",SETDIG,{ SET-DIGIT COMMAND.})
$$("7",SETDIG,{ SET-DIGIT COMMAND.})
$$("8",SETDIG,{ SET-DIGIT COMMAND.})
$$("9",SETDIG,{ SET-DIGIT COMMAND.})
$$(":",EUTRAN,{ EUCLIDEAN TRANSFORMATION +X.})
$$(";",EUTRAN,{ EUCLIDEAN TRANSFORMATION -X.})
$$("<",LINKER,{ FETCH NFACE LINK.})
$$("=",SWC3,{ DILATION DEFAULT SWITCH.})
$$(">",LINKER,{ FETCH PFACE LINK.})
$$("?",QMARK,{ INFORMATION PREFIX.})
$$("@",SWC2,{ ROTATION DEFAULT SWITCH.})
;----------------------------------------------------------------
;ASCII 101 TO 132 UPPER CASE-------------------------------------
;ASCII 141 TO 172 LOWER CASE.
A101:
$$("A",ATTDET,{ A ATTACH, αA ARROW, βAXECNT.})
$$("B",XBODY ,{ B BODY RETRIEVAL.})
$$("C",XCOPY ,{ C COPY. αC GET CAMERA.})
$$("D",ATTDET,{ D DETACH, αDARKEN, βDUAL, εUNDARKEN.})
$$("E",SWIRE ,{ E SWEEP WIRE, εE EXIT.})
$$("F",SWCF,{ F FRAME STEP SWITCH.})
$$("G",XGLUE,{ G GLUE COMMAND.})
$$("H",COMHLP,{ H HELP})
$$("I",XIN,{ I INPUT B3D. αI CAMERA. βI CRE. εI D3D.})
$$("J",JOINVV,{ J JOIN VERTEX-VERTEX.})
$$("K",XKILL,{ K KILL COMMANDS.})
$$("L",SWCL,{ L LABEL LIGHTS SWITCH.})
$$("M",MIDPOI,{ M MIDPOINT COMMAND.})
$$("N",XNAME,{ N NAME BODY})
$$("O",XOUT,{ O OUTPUT B3D. αO CAMERA. βO TRI FOR MAKVID. εO D3D.})
$$("P",XPLOTO,{ P OUTPUT PLOT FILE})
$$("Q",SWCQ,{ Q FRAME ORIGIN SWITCH.})
$$("R",XROTCM,{ R ROTATION COMPLETION.})
$$("S",XSWEEP,{ S SWEEP. αS PYRAMID. βS SMOOTH SWEEP. εSMOOTH PYRAMID.})
$$("T",XTEXT,{ T TEXT LABEL. αT TAKE A PICTURE. εβ TRIANGLE SWEEP.})
$$("U",NOP,{ U})
$$("V",VBODY,{ V MAKE VERTEX BODY.})
$$("W",XWMAKE,{ MAKE: W WORLD. αW WINDOW. βW CAMERA. εW IMAGE.})
$$("X",EXTEND,{X EXTENDED COMMANDS.})
$$("Y",NOP,{ Y NOP})
$$("Z",NEWMAC,{ Z MACRO CALL, αZ EDIT MACRO, βZ TAKE COMMANDS FROM FILE.})
;ASCII 133 TO 140.
$$("[",NOP,{ [})
$$("\",DOUBLE,{ \ DOUBLE STRENGTH.})
$$("]",NOP,{ ]})
$$("↑",PADPOP,{ ↑ PADPDL POP. α↑ ROTATE POP.})
$$("←",LINKER,{ ← FETCH ALT LINK.})
$$("`",NOP,{ `})
;ASCII 173 TO 177.
A173:
$$("{",NOP,{ LEFT CURLY.})
$$("|",XINVERT,{ | INVERT EDGE PARITY.})
$$(" ",XDPY,{ ALT OCCULT. αALT FRONT FACE. βALT ALL EDGES.})
$$("}",NOP,{ RIGHT CURLY})
$$(" ",NOP,{ RUBOUT})
;----------------------------------------------------------------
SUBR(VBODY) ;MAKE VERTEX BODY.
LAC PTR,PDLPTR
SETQ(BNEW,{MKB,WORLD})
PUSH PTR,1 ;BODY INTO PADPDL
SKIPE META↔GO L1 ;DISABLE FACE & VERTEX.
CALL(MKF,BNEW)↔PUSH PTR,1 ;FACE INTO PADPDL
CALL(MKV,BNEW)↔PUSH PTR,1 ;VERTEX INTO PADPDL
L1: DAC PTR,PDLPTR
SKIPE CTRL↔POP0J ;DISABLE MAKE FRAME.
CALL(MKFRAME)↔LAC 2,BNEW
FRAME. 1,2
POP0J
BNEW: 0
ENDR;2/4/73(BGB)-----------------------------------------------------
SWIRE:
SKIPN MTCT↔GO .+4↔POP P,0
SETZ 1,↔POP0J ;"εE" - EXIT GEOMED.
CDR PTR,PDLPTR
CAIGE PTR,PADPDL+2↔POP0J ;PADPDL EMPTY TEST.
CALL(LINKED,{-1(PTR)},{(PTR)}) ;LEGAL ARGS TEST.
SKIPN 1↔POP0J
LAC PTR,PDLPTR
CALL(MKEV,{-1(PTR)},{(PTR)}) ;MAKE EDGE VERTEX.
LAC PTR,PDLPTR↔DAC 1,(PTR)
POP0J
SUBR(JOINVV)
ACCUMULATORS{F,V1,V2,E1,E2}
LAC PTR,PDLPTR↔CDR 1,PTR
CAIGE 1,PADPDL+2↔POP0J ;REQUIRES TWO ARGUMENTS.
LAC V1,(PTR)
LAC V2,-1(PTR)↔DAC V2,F
TEST V1,VBIT↔POP0J ;AT LEAST ONE VERTEX.
TEST F,FBIT↔GO L1
;JOIN ENDS OF WIRE CASE.
PED E1,F↔PVT V2,E1↔DAC V2,(PTR)
CALL(MKFE,V2,F,V1)
CALL(GEODPY)
POP0J
;JOIN VERTICES ACROSS A FACE.
L1: TEST V2,VBIT↔POP0J
PED E1,V1↔DAC E1,E0#
L2: SETQ(F,{FCCW,E1,V1})
PED E2,V2↔DAC E2,EE0#
L3: CALL(FCCW,E2,V2)↔CAMN 1,F↔GO L4 ;FACE IN COMMON.
SETQ(E2,{ECCW,E2,V2})↔CAME E2,EE0↔GO L3
SETQ(E1,{ECCW,E1,V1})↔CAME E1,E0↔GO L2↔POP0J
L4: POP PTR,0
CALL(MKFE,V1,F,V2)↔DAC 1,(PTR)
DAC PTR,PDLPTR
CALL(GEODPY)
POP0J
ENDR JOINVV;2/5/73(BGB)
SUBR(MIDPOI) ;MIDPOINT AN EDGE PROPORTIONAL TO DDEL
;---------------------------------------------------------------------
CDR PTR,PDLPTR↔CAIGE PTR,PADPDL+1↔POP0J
LAC 1,(PTR)↔TEST 1,EBIT↔POP0J
PVT 0,1↔DAC V1#
NVT 0,1↔DAC V2#
CALL(ESPLIT↑,1)↔DAC 1,(PTR)
LAC 2,V1↔SLACI XWC(2)↔LAPI XWC(1)↔BLT ZWC(1)
LAC DDEL↔FMPRM XWC(1)↔FMPRM YWC(1)↔FMPRM ZWC(1)
LAC 2,V2↔SLACI 3,(1.0)↔FSBR 3,DDEL
LAC XWC(2)↔FMPR 3↔FADRM XWC(1)
LAC YWC(2)↔FMPR 3↔FADRM YWC(1)
LAC ZWC(2)↔FMPR 3↔FADRM ZWC(1)
CALL(GEODPY)
POP0J↔VAR
ENDR MIDPOI;2/8/73(BGB)----------------------------------------------
XINVERT: ;FLIP THE FACE-VERTEX ORIENTATION OF AN EDGE.
CDR PTR,PDLPTR
CAIGE PTR,PADPDL+1↔POP0J
LAC 1,(PTR)
TEST 1,EBIT↔POP0J
MOVSS 1(1)↔MOVSS 3(1)↔MOVSS 4(1)↔MOVSS 5(1)
POP0J
XEVERT:
SKIPE CTRL↔GO XBIN ;BODY SUBTRACTION.
CDR PTR,PDLPTR
CAIGE PTR,PADPDL+1↔POP0J
LAC 1,(PTR)↔TEST 1,BBIT↔POP0J
CALL(EVERT↑,1)
CALL(GEODPY)
POP0J
SUBR(EUTRAN)
COMMENT ⊗------------------------------------------------------------
Apply a Euclidean transformation to an object.
⊗
EXTERN BGET,APTRAN,MKFRAME,MKCOPY,KLNODE
EXTERN TRANSLATE,ROTATE,SHRINK
;GET TOP OBJECT OF PADPDL.
CDR 1,PDLPTR↔CAIGE 1,PADPDL+1↔POP0J
LAC 2,(1)↔DAC 2,OBJECT
$TYPE 0,2↔CAIN 0,$WINDOW↔GO WNTRAN
DZM DEL1↔DZM DEL2↔DZM DEL3
;OPERATION.
SKIPN 1,MCBITS↔LAC 1,OPERAT↔DAC 1,OP
LAC 2,[TRANSLATE↔ROTATE↔SHRINK↔SHRINK](1)
DAP 2,L3
;AXIS CODE.
LAC 1,CHR↔SETZ 3,
CAIE 1,";"↔CAIN 1,":"↔IORI 3,1 ;X-AXIS.
CAIE 1,"("↔CAIN 1,")"↔IORI 3,2 ;Y-AXIS.
CAIE 1,"-"↔CAIN 1,"*"↔IORI 3,4 ;Z-AXIS.
LAC 1,OP↔CAILE 1,1↔GO[
SLACI(1.0)↔DAC DEL1↔DAC DEL2↔DAC DEL3
LAC AXECNT↔CAIN 2↔TRC 3,7
CAIN 3↔TRO 3,7↔GO .+1]
;DELTA ARGUMENT.
LAC CHR↔LAC 1,OP
LAC 2,@[TDEL↔RDEL↔DDEL↔[-1.0]](1)
CAIN"-"↔MOVNS 2
CAIN"("↔MOVNS 2
CAIN";"↔MOVNS 2
GO@[L1↔L1↔[MOVNS 2↔JUMPGE 2,L1 ;NEGATIVE DILATION.
SLACI 2,(1.0)↔FDVR 2,DDEL↔GO L1] ;POSITIVE DILATION.
[LAC 2,[-1.0]↔GO L1]](1) ;REFLECTION DELTA.
L1: TRNE 3,1↔DAC 2,DEL1
TRNE 3,2↔DAC 2,DEL2
TRNE 3,4↔DAC 2,DEL3
;----- EUTRAN ;MAKE REFERENCE FRAME.
LAC 1,FRAAM↔GO@[[GO .+1] ;WORLD FRAME.
[CALL(BGET,OBJECT)↔GO .+1] ;BODY FRAME.
[CALL(BGET,OBJECT)↔DAD 1,1↔GO .+1] ;DADDY'S FRAME.
[LAC 1,CAMERA↔GO .+1]](1) ;CAMERA FRAME.
SKIPE 1↔FRAME 1,1
SKIPE 1↔GO[CALL(MKCOPY,1)↔GO .+1] ;COPY OF REFRAM.
DIPZ 1,REFRAM ;XWD REFRAM,0
;FRAME ORIGIN SWITCH.
SKIPN FRMORG↔GO[SKIPN OP↔GO .+1 ;NON-TRANSLATION.
CALL(BGET,OBJECT)↔FRAME 1,1
JUMPE 1,.+1↔PUSH P,1
CAR 1,REFRAM↔SKIPN 1↔CALL(MKFRAME)↔DIPZ 1,REFRAM
LAC 2,1↔POP P,1↔SLACI XWC(1)
LAPI XWC(2)↔BLT ZWC(2)↔GO .+1]
;MAKE EUCLIDEAN TRANSFORMATION MATRIX.
CALL(,REFRAM,DEL1,DEL2,DEL3)
L3: CALL(ROTATE)↔DAC 1,TRAN ;MAKE THE TRANSFORM.
SKIPE REFRAM↔GO[CAR REFRAM↔CALL(KLNODE,0)↔GO .+1];FLUSH THE REFRAM.
LAC ITERAT↔SKIPN↔AOS↔DAC COUNT
L2: CALL(APTRAN,OBJECT,TRAN)
CALL(GEODPY)
SKIPGE COUNT↔GO[
AOSL COUNT↔GO .+1
SETZM ITERAT
CALL(XSWEEP)
CDR 1,PDLPTR↔LAC(1)↔DAC OBJECT↔GO L2]
SOSLE COUNT↔GO L2
SETOM@TRAN
CALL(KLNODE,TRAN)
POP0J
DECLARE{OBJECT,TRAN,REFRAM,COUNT,OP,DEL1,DEL2,DEL3}
WNTRAN: LAC 1,CHR ;WINDOW TRANFORMATION.
CAIN 1,"-"↔GO[LAC -1(2)↔FMPR DDEL↔DAC -1(2)
SKIPE CTRL↔GO W2↔GO W1]
CAIN 1,"*"↔GO[LAC -1(2)↔FDVR DDEL↔DAC -1(2)
SKIPE CTRL↔GO W2↔GO W1]
LAC 3,TDEL↔FIXX 3, ;TRANSLATION.
LACI 4,-2(2)↔SKIPE CTRL↔SOS 4 ;ADDRESS.
CAIN 1,";"↔GO[NIP(4)↔SUB 3↔DIP(4)↔GO W1]
CAIN 1,":"↔GO[NIP(4)↔ADD 3↔DIP(4)↔GO W1]
CAIN 1,"("↔GO[NAP(4)↔SUB 3↔DAP(4)↔GO W1]
CAIN 1,")"↔GO[NAP(4)↔ADD 3↔DAP(4)↔GO W1]
POP0J
W1: CALL(CROP,2)↔EXTERN CROP
W2: CALL(GEODPY)↔POP0J
ENDR EUTRAN;2/4/73(BGB)-----------------------------------------------
;SWITCH COMMANDS.
; ! TRANSLATION DEFAULT.
; @ ROTATION DEFAULT.
; ∃ REFLECTION DEFAULT.
; = DILATION DEFAULT.
; Q FLIP FRAME ORIGIN.
; F STEP FRAME SELECT SWITCH.
; ≡ TOGGLE STATUS DISPLAY ENABLE.
SWC1: SETZM OPERAT↔POP0J ;"!" TRANSLATION DEFAULT.
SWC2: LACI 1↔DAC OPERAT↔POP0J ;"@" ROTATION DEFAULT.
SWC3: LACI 2↔DAC OPERAT↔POP0J ;"=" DILATION DEFAULT.
SWC4: LACI 3↔DAC OPERAT↔POP0J ;"∃" REFLECTION DEFAULT.
SWCF: SKIPE CTRL↔GO XFOCAL ;"αF" SET FOCAL.
AOS 1,FRAAM↔ANDI 1,3
DAC 1,FRAAM↔POP0J ;FRAME STEP SWITCH.
SWCL: SETCMM FLAGL↔POP0J ;"L" LABEL LIGHTS SWITCH.
SWCD: SETCMM FLAGD↔POP0J ;"∂" NODE DISPLAY SWITCH.
SWCQ: SETCMM FRMORG↔POP0J ;FRAME ORGIN TOGGLE.
SWCSD: SETCMM FLAGSD↔POP0J ;STATUS DISPLAY TOGGLE.
CRLF20: OUTSTR[BYTE(7)14,14]↔POP0J ;TWENTY CRLF'S.
XDISBL: CDR 1,PDLPTR↔CAIGE 1,PADPDL+1↔POP0J
LAC 1,(1)↔TEST 1,BBIT↔POP0J
LAC 2,MCBITS↔GO@[
[MARKZ 1,{BDLBIT+BDVBIT+BDPBIT}↔POP0J] ;ENABLE.
[MARK 1,BDLBIT↔POP0J] ;FRAME DISABLE
[MARK 1,BDVBIT↔POP0J] ;VERTEX DISABLE
[MARK 1,BDPBIT↔POP0J]](2) ;PARTS DISABLE
;STACK MODIFYING COMMANDS. ;"↔↓↑"
;"↔" PADPDL SWAP: PADPDL[1]↔PADPDL[2].
;"α↔" PADPDL SWAP: PADPDL[1]↔PADPDL[3].
;"β↔" PADPDL SWAP: PADPDL[2]↔PADPDL[3].
;"ε↔" PADPDL SWAP: PADPDL[1]↔PADPDL[N].
PADSWP: LAC PTR,PDLPTR↔CDR PTR
LACM 1,CTRL↔CAIGE PADPDL+2(1)↔POP0J ;ARG ∃ TEST.
LAC 1,MCBITS↔GO@[
[LAC(PTR)↔EXCH -1(PTR)↔DAC(PTR)↔POP0J] ; 1ST & 2ND.
[LAC(PTR)↔EXCH -2(PTR)↔DAC(PTR)↔POP0J] ;α 1ST & 3RD.
[LAC(PTR)↔EXCH PADPDL+1↔DAC(PTR)↔POP0J] ;β 1ST & LAST.
[LAC -1(PTR)↔EXCH -2(PTR)
DAC -1(PTR)↔POP0J] ;ε 2ND & 3RD.
](1)↔LIT
;"↓" PADPDL COPY PUSH DOWN.
;"↓" PADPDL ROTATE DOWN.
PADPSH: LAC PTR,PDLPTR↔CDR PTR
CAIGE PADPDL+1↔POP0J
SKIPE CTRL↔GO .+4
PUSH PTR,(PTR)↔DAC PTR,PDLPTR↔POP0J ;COPY PUSH.
LAC[XWD PADPDL+1,PADPDL]↔BLT -1(PTR)
LAC PADPDL↔DAC(PTR)↔POP0J ;ROTATE PUSH.
;"↑" PADPDL POP UP.
;"α↑" PADPDL ROTATE UP.
PADPOP: LAC PTR,PDLPTR↔CDR PTR
CAIGE PADPDL+1↔POP0J
SKIPE CTRL↔GO .+4
POP PTR,↔DAC PTR,PDLPTR↔POP0J ;PAD POP.
SUBI PADPDL↔POP PTR,1(PTR)↔SOJG .-1 ;ROTATE POP
LAC PTR,PDLPTR↔LAC 1(PTR)↔DAC PADPDL+1
POP0J
;STRENGTH COMMANDS.
;"/" COMMAND.-----------------------------------------------------
HALVE: SKIPN 1,MCBITS↔LAC 1,OPERAT ;EUCLIDEAN OPERATION.
LAC TDEL(1)↔FSC -1↔DAC TDEL(1) ;"/" COMMAND.
POP0J
;"\" COMMAND.-----------------------------------------------------
DOUBLE: SKIPN 1,MCBITS↔LAC 1,OPERAT ;EUCLIDEAN OPERATION.
LAC TDEL(1)↔FSC 1↔DAC TDEL(1) ;"\" COMMAND.
POP0J
;"0123456789" COMMANDS.-------------------------------------------
SETDIG: LAC 1,CHR↔ANDI 1,17 ;DIGIT.
SKIPN 2,MCBITS↔LAC 2,OPERAT ;EUCLIDEAN OPERATION.
GO@[
[LAC ITERAT↔IMULI 12↔ADD 1 ;ITERATION COUNT.
CAILE=128↔LACI=128
DAC ITERAT↔POP0J]
[SUBI 1,=10↔LAC[3.1415927] ;ROTATION DELTA.
FSC(1)↔DAC RDEL↔POP0J]
[SKIPN 1↔LACI 1,1↔FLOAT 1, ;DILATION DELTA.
FMPR 1,[0.1]↔DAC 1,DDEL↔POP0J]
[SUBI 1,4↔SLACI(1.0)↔FSC(1) ;TRANSLATION DELTA.
DAC TDEL↔POP0J]](2)
;-----------------------------------------------------------------
EXTERNAL REALIN
XTDEL: CALL(REALIN)↔CAIN 1,42↔FDVR[12.0]↔DAC TDEL↔POP0J
XDDEL: CALL(REALIN)↔FMPR[0.01]↔DAC DDEL↔POP0J
XRDEL: CALL(REALIN)↔CAIN 1,"/"↔GO[
SKIPN↔SLACI(1.0)↔DAC RDEL ;NUMERATOR.
CALL(REALIN)↔SKIPN↔SLACI(1.0) ;DENOMINATOR.
LAC 1,RDEL↔FMPR 1,[3.1415927]
FDVR 1,0↔DAC 1,RDEL↔POP0J] ;PI FRACTION.
CAIN 1,"'"↔FMPR[1.74532925E-2] ;DEGREES.
DAC RDEL↔POP0J ;RADIANS.
;COMMAND XFOCAL
XFOCAL:
OUTSTR[ASCIZ/ FOCAL = /]↔CALL(REALIN)
LAC 1,CAMERA
FMPR[3.2808E-3]↔HLLM 0,3(1)
HLLZ 2,1(1)↔CDR 3,1(1)↔FLOAT 3,↔FMPR 3,0↔FDVR 3,2↔DACN 3,-3(1)
HLLZ 2,2(1)↔CDR 3,2(1)↔FLOAT 3,↔FMPR 3,0↔FDVR 3,2↔DACN 3,-2(1)
FMPR[100000.0]↔DAC 0,-1(1)
CALL(GEODPY)
POP0J
SUBR(XSWEEP)
COMMENT ⊗------------------------------------------------------------
⊗↔ EXTERN SWEEP,PYRAMID
CDR PTR,PDLPTR↔CAIGE PTR,PADPDL+1↔POP0J ;ARG EXISTS.
LAC 1,(PTR)↔TESTZ 1,FBIT↔GO L2
TEST 1,VBIT↔POP0J
PED 2,1↔JUMPE 2,.+4
MOVS 0,1(2)↔CAME 0,1(2)↔GO [ SETOM CTRL↔GO L2A ]
CALL(SWIRE)↔GO L3 ;SWEEP WIRE.
COMMENT ⊗
L2: SKIPE MTCT↔GO[L2A:
CALL(PYRAMID,1)↔DAC 1,(PTR)
CALL(GEODPY)↔POP0J]
SKIPN 2,META↔LACM 2,CTRL ;0=PRISM ;α+1=CCW ;β-1=CW.
CALL(SWEEP,1,2)
⊗;
L2: LAC CHR↔CAIN "T"
GO [ SKIPL 2,CTRL
LACI 2,1
GO L2B ]
L2A: SETZ 2,
SKIPE META↔HRLI 2,-1
SKIPE CTRL
GO [ CALL(PYRAMIND,1)↔DAC 1,(PTR)
CALL(GEODPY)↔POP0J ]
L2B: CALL(SWEEP,1,2)
L3: CALL(GEODPY)
MOVNS ITERAT
POP0J
ENDR XSWEEP;2/10/73(BGB)---------------------------------------------
XROTCM:
CDR PTR,PDLPTR
CAIGE PTR,PADPDL+1↔POP0J
LAC 1,(PTR)↔TEST 1,FBIT↔POP0J
CALL(ROTCOM↑,1)
CALL(GEODPY)
POP0J
;____________________________________________________________________
XGLUE: LAC PTR,PDLPTR↔CDR PTR↔CAIGE PADPDL+2↔POP0J ;TWO ARGS.
LAC 1,(PTR)↔LAC 2,-1(PTR)
EXTERN GLUE
CALL(GLUE,1,2)↔DAC 1,-1(PTR)
POP PTR,0↔DAC PTR,PDLPTR
CALL(GEODPY)
POP0J
;____________________________________________________________________
SUBR XKILL ;"K"
COMMENT ⊗------------------------------------------------------------
⊗↔ EXTERN KLEV,KLVE,KLFE,REMOVF,KLBFEV
LAC PTR,PDLPTR↔CDR PTR↔CAIGE PADPDL+1↔POP0J ;ONE ARG.
LAC 1,(PTR)
TEST 1,VBIT↔GO L2
DAC 1,2↔PED 3,1↔JUMPE 3,L4
SETQ(4,{ECCW,3,2})
SETQ(5,{ECCW,4,2})
DAC 2,1↔CAME 3,5↔GO L1
CALL(KLEV,1)↔GO L3
L1: CALL(KLEV,1)↔CALL(KLFE,1)↔GO L3
L2: TESTZ 1,EBIT↔GO[SKIPE CTRL↔GO[
CALL(KLVE,1)↔GO L3]
CALL(KLFE,1)↔GO L3]
TESTZ 1,FBIT↔GO[CALL(REMOVF,1)↔GO L3]
TESTZ 1,BBIT↔GO[L4: CALL(KLBFEV,1)↔POP PTR,0
DAC PTR,PDLPTR↔CALL(GEODPY)↔POP0J]
POP0J
L3: DAC 1,(PTR)
CALL(GEODPY)
POP0J
ENDR XKILL;2/10/73(BGB)-------------------------------------------------
SUBR LINKER ;LINK FOLLOWING COMANDS.
COMMENT ⊗------------------------------------------------------------
⊗↔ LAC PTR,PDLPTR
LAC CHR↔CAIN"⊗"↔GO[PUSH PTR,UNIVERSE↔DAC PTR,PDLPTR↔POP0J]
CDR 1,PTR↔CAIGE 1,PADPDL+1↔POP0J ;STACK EMPTY.
LAC 2,(1)↔LAC CHR
CAIE"."↔CAIN","↔GO L1 ;CLOCK LINK COMMANDS.
CAIN"+"↔GO L1 ;OTHER LINK COMMAND.
CAIN"∩"↔GO[SKIPE CTRL↔GO XBIN↔TESTZ 2,PBIT↔DAD 2,2↔GO L0]
CAIN"∪"↔GO[SKIPE CTRL↔GO XBIN↔SON 2,2↔GO L0]
CAIN"⊂"↔GO[TESTZ 2,PBIT↔BRO 2,2↔GO L0]
CAIN"⊃"↔GO[TESTZ 2,PBIT↔SIS 2,2↔GO L0]
CAIE "<"↔CAIN ">"↔ADDI 2,1
CAIE "≤"↔CAIN "≥"↔ADDI 2,2
CAIE "∨"↔CAIN "∧"↔ADDI 2,3
CAIE "←"↔CAIN "→"↔GO[ADDI 2,6↔SKIPN MCBITS↔GO .+1↔GO L6]
SKIPE CTRL↔SUBI 2,4 ;-3 -2 -1
SKIPE META↔ADDI 2,5 ;6 7 8
SKIPE MTCT↔ADDI 2,2 ;4 5 6
LAC 2,(2) ;FETCH WORD FROM THE NODE.
CAIN "≤"↔MOVSS 2
CAIN "<"↔MOVSS 2
CAIN "∨"↔MOVSS 2
CAIN "←"↔MOVSS 2
L0: CDR 2
CAML 44↔GO .+3 ;LOWER THAN MAX.
CAML UNIVER↔DAC(1) ;HIGHER THAN MIN.
POP0J
;----- LINKER ;OTHER LINK COMMANDS.
L1: TESTZ 2,PBIT↔GO[LAC CHR ;OBJECT CLOCK LINKS.
CAIN"."↔GO[CCW 2,2↔DAC 2,(1)↔POP0J] ;CCW BODY.
CAIN","↔GO[ CW 2,2↔DAC 2,(1)↔POP0J] ; CW BODY.
POP0J]
ANDI 0,17 ;GET TYPE NUMBER
CAIN 0,$TEXT
GO [LAC CHR ;SPECIAL HACK FOR TEXT LIST
CAIN"."↔GO[TCCW 2,2↔SKIPE 2↔DAC 2,(1)↔POP0J] ;CCW TEXT
CAIN","↔GO[ TCW 2,2↔DAC 2,(1)↔POP0J] ; CW BODY.
POP0J]
CAIGE 1,PADPDL+2↔POP0J ;TWO ARGUMENTS REQUIRED.
LAC 1,0(PTR)↔LAC 2,-1(PTR)
CALL(LINKED,1,2)↔SKIPN 1↔POP0J ;WHICH ARE LINKED.
LAC 1,0(PTR)↔LAC 2,-1(PTR)
SETZ 3,↔LAC CHR
CAIN"+"↔GO L2
CAIE","↔AOS 3 ;DISTINGUISH CW & CCW.
SKIPN CTRL↔ADDI 3,2
SKIPE CTRL↔ADDI 3,4 ;DISTINGUISH OPERATION.
;EDGE IS IN THE FIRST POSITION OF THE STACK.
L2: TEST 1,EBIT↔GO L3 ;EDGE.
TEST 2,FBIT↔GO[TEST 2,VBIT↔POP0J ;FACE OR VERTEX.
SKIPE CTRL↔ADDI 3,2↔GO .+1] ;CTRL VERTEX.
PUSH P,1↔PUSH P,2↔PUSHJ P,@L5(3)
CAIN 3,2↔AOS PTR↔CAIN 3,3↔AOS PTR
DAC 1,-1(PTR)↔POP0J
;EDGE IS IN THE SECOND POSITION OF THE STACK.
L3: TEST 2,EBIT↔POP0J
TEST 1,FBIT↔GO[TEST 1,VBIT↔POP0J
SKIPE CTRL↔ADDI 3,2↔GO .+1]
PUSH P,2↔PUSH P,1↔PUSHJ P,@L5(3)
CAIN 3,2↔SOS PTR↔CAIN 3,3↔SOS PTR
DAC 1,0(PTR)↔POP0J
L5: OTHER↔OTHER↔ECW↔ECCW↔VCW↔VCCW↔FCW↔FCCW
;STEP ALONG IMAGE RINGS OF THE "NOW" CAMERA.
L6: LAC 1,UNIVERSE
NWRLD 1,1↔NCAMR 1,1
SKIPE CTRL↔GO L7
PIMAG 2,1↔SKIPN 2↔POP0J↔PTIME 3,2↔CAIE"→"↔NTIME 3,2↔PIMAG. 3,1
CALL(GEODPY)↔POP0J
L7: SIMAG 2,1↔SKIPN 2↔POP0J↔PTIME 3,2↔CAIE"→"↔NTIME 3,2↔SIMAG. 3,1
CALL(GEODPY)↔POP0J
ENDR LINKER;2/9/73(BGB)----------------------------------------------
;COMMANDS XNAME,XBODY ;"B","N"
SUBR(XNAME) ;NAME A BODY
COMMENT ⊗------------------------------------------------------------
⊗↔ CDR 1,PDLPTR↔CAIGE 1,PADPDL+1↔POP0J
LAC 1,(1)↔TEST 1,BBIT↔POP0J
CALL(RDNAME)
JUMPE 6,[ OUTSTR[ASCIZ/ILLEGAL NAME.
*/]↔ POP0J]
CALL(FNDNAME)
GO [ LAC 1,PDLPTR↔LAC 1,(1)
DAC 4,-2(1)↔DAC 5,-1(1)
OUTSTR[ASCIZ/*/]↔POP0J ]
OUTSTR[ASCIZ/NAME ALREADY IN USE.
*/]↔ POP0J
ENDR XNAME;2/9/73(BGB)-----------------------------------------------
SUBR(XBODY) ;BODY RETRIEVAL.
COMMENT ⊗------------------------------------------------------------
⊗↔ LAC PTR,PDLPTR
SKIPN CTRL↔GO[CDR 1,PTR↔CAIGE 1,PADPDL+1↔GO .+1
CALL(BGET,{(PTR)})↔DAC 1,(PTR)↔POP0J]
CALL(RDNAME)↔JUMPN 6,L2
;FETCH BODY BY ITS SERIAL NUMBER.
LAC 1,WORLD↔CCW 1,1
CAME 1,WORLD↔SOJG 3,.-2
CAME 1,WORLD↔GO RET
LOSE: OUTSTR[ASCIZ/BODY NOT FOUND.
*/]↔ POP0J
;FETCH BODY BY ITS PNAME.
L2: CALL(FNDNAME)
GO LOSE
RET: PUSH PTR,1
DAC PTR,PDLPTR
OUTSTR[ASCIZ/*/]↔POP0J
ENDR XBODY;2/9/73(BGB)-----------------------------------------------
SUBR RDNAME
COMMENT ⊗------------------------------------------------------------
⊗↔ OUTSTR[ASCIZ/ :/]
LACI 2,=10 ;TEN CHARACTERS TO A NAME.
LAC 1,[POINT 7,4,-1]
SETZB 3,6 ;BODY SERIAL NUMBER.
SETZB 4,5
L: CALL(GETCL0)↔CAIN 15↔GO EOL ;END OF LINE.
IDPB 1↔CAIGE"0"↔GO .+3↔CAIG"9"↔GO[
IMULI 3,12↔ANDI 0,17↔ADD 3,0↔GO .+2]
SETOM 6 ;NON-NUMERIC CHR SEEN.
SOJG 2,L
CALL(GETCL0)↔CAIE 15↔GO .-2
CRLF
SKIPA
EOL: CALL(GETCL0)↔POP0J
ENDR RDNAME;(TVR)----------------------------------------------------
SUBR FNDNAME ;FETCH BODY BY ITS PNAME.
COMMENT ⊗------------------------------------------------------------
⊗↔L2: LAC 1,WORLD↔CCW 1,1
CAME 1,WORLD
GO[CAME 4,-2(1)↔GO L2+1
CAME 5,-1(1)↔GO L2+1↔GO .+1]
CAME 1,WORLD↔AOS(P)
POP0J
ENDR FNDNAME;2/9/73(BGB)---------------------------------------------
SUBR(INSTANT)
OPDEF PTO[711440B17]
LAC 1,MCBITS
PTO @[[0↔MACRO0]
[0↔MACRO1]
[0↔MACRO2]
[0↔MACRO3]] (1)
POP0J
MACRO0: ASCIZ"V\:)\E;E(E:J↑/*S--↑/@/:)\!"
MACRO1: ASCIZ"V:7@S*J!↑8/:\@S)↓>G↑:)!"
MACRO2: ASCIZ"⊗αW↔∪A⊃⊃↔βWA↑βAβAβ/β-λ256
):↔β-);//β\β*(↔β*(λ.25
⊃:↔⊂;\\↑↑βA"
MACRO3: 0
ENDR INSTANT;2/9/73(BGB)---------------------------------------------
SUBR(ATTDET) ;ATTACH-DETACH COMMANDS & FRIENDS.
COMMENT ⊗------------------------------------------------------------
⊗↔ EXTERN BDET,BATT,FVDUAL
LAC 1,CHR
CAIE 1,"D"↔GO L4
;DETACH, αDARKEN, βDUAL, εUNDARKEN.
CDR 1,PDLPTR↔CAIGE 1,PADPDL+1↔POP0J ;DETACH.
LAC 1,(1)↔TEST 1,BBIT↔GO L3
SKIPE META↔GO[CALL(FVDUAL,1)↔CALL(GEODPY)↔POP0J]
CALL(BDET,1)↔POP0J
L3: TEST 1,EBIT↔POP0J
SLACI 0,(DARKEN)↔IORM(1)↔SKIPE META↔ANDCAM(1)
CALL(GEODPY)↔POP0J
;ATTACH, αNOP, βAXECNT.
L4: ;SKIPE CTRL↔GO XARROW
SKIPE META↔GO[AOS 1,AXECNT ;STEP AXECNT.
CAIL 1,4↔LACI 1,1↔DAC 1,AXECNT
POP0J]
CDR 1,PDLPTR↔CAIGE 1,PADPDL+2↔POP0J ;ATTACH.
LAC 2,-1(1)↔LAC 1,(1)
CALL(BATT,1,2)↔POP0J
ENDR ATTDET;2/9/73(BGB)----------------------------------------------
XDPY:
LAC 1,CHR
CAIN 1,"_"↔GO[LAC MCBITS↔DAC DPYFLG↔CALL(GEODPY)↔POP0J]
CAIE 1,175↔POP0J
LAC MCBITS↔PUSH P,DPYFLG↔DAC DPYFLG↔DAC ODPYFLG
CALL(GEODPY)↔POP P,DPYFLG↔POP0J
XCOPY:
SKIPE CTRL↔GO[LAC 1,PDLPTR↔PUSH 1,CAMERA↔DAC 1,PDLPTR↔POP0J]
LAC 16,PDLPTR↔CDR 1,16
CAIGE 1,PADPDL+1↔POP0J
CALL(MKCOPY↑,{(1)})
PUSH 16,1↔DAC 16,PDLPTR
LACI 2↔DAC DPYFLG↔CALL(GEODPY) ;DON'T OCCULT.
POP0J
XIN:
EXTERN ICAM,INCRE,IFORM0,IFORM1 ;INPUT FORMAT TYPE-1.
SKIPE CTRL↔GO[SKIPE META
GO [ CALL(IFORM0)↔CALL(GEODPY)↔POP0J] ;εI D3D.
CALL(ICAM)↔CALL(GEODPY)↔POP0J] ;αI CAM.
SKIPE META↔GO[CALL(INCRE)↔CALL(GEODPY)↔POP0J] ;βI CRE.
CALL(IFORM1)↔SKIPN 1↔POP0J ; I B3D.
LAC 16,PDLPTR↔PUSH 16,1↔DAC 16,PDLPTR
CALL(GEODPY)
POP0J
XOUT:
EXTERN OCAM,OFORM0,OFORM1,OFORM2
SKIPE CTRL↔GO[SKIPE META
GO[CALL(OFORM0)↔POP0J] ; εO D3D.
CALL(OCAM)↔POP0J] ; αO CAM.
SKIPE META↔GO[CALL(OFORM2)↔POP0J] ; βO TRI.
CDR 1,PDLPTR↔CAIGE 1,PADPDL+1↔POP0J
CALL(OFORM1,{(1)}) ; O B3D.
POP0J
COMHLP: ;HELP COMMAND.
SKIPN CTRL↔GO .+4
SETZB 0,1 ;"αH" CLEAR HELP DISPLAY.
UPGIOT 16,0↔POP0J
CALL(TVHELP↑,[[SIXBIT/GEOMEDHLP/↔0↔SIXBIT/DOCBGB/]])
POP0J
XBIN:
EXTERN BIN,BUN,BSUB,KLBFEV,MKCVEX
CDR 1,PDLPTR↔CAIGE 1,PADPDL+2↔POP0J
LAC 2,-1(1)↔LAC 1,(1)↔LAC CHR
CAIN"∩"↔GO[CALL(BIN,2,1)↔GO .+5] ;INTERSECTION.
CAIN"∪"↔GO[CALL(BUN,2,1)↔GO .+3] ;UNION.
CAIN"¬"↔GO[CALL(BSUB,2,1)↔GO .+1] ;SUBTRACTION.
PUSH P,1
CALL(GEODPY)↔CALL(MKCVEX,{(P)})
LAC 1,PDLPTR↔POP 1,2↔DAC 1,PDLPTR
CALL(KLBFEV,2)↔CDR 1,PDLPTR↔LAC 2,(1)↔POP P,(1)
CALL(KLBFEV,2)
CALL(GEODPY)
POP0J
XWMAKE:
LAC 1,MCBITS
PUSHJ P,@[MKWORLD↑↔MKWINDOW↑↔MKCAMERA↑↔MKCAMERA↑](1)
LAC PTR,PDLPTR
PUSH PTR,1↔DAC PTR,PDLPTR
POP0J
XPLOTO:
CALL(PLOTO↑)
OUTCHR["*"]
POP0J
SUBR(NEWMAC)
EXTERNAL MACPTR,MACCNT,MACNOD,IFORM2
↑NEWMAC:SKIPE META
JCALL IFORM2
SKIPN CTRL
GO [ CALL(RDNAME)
CALL(FNDNAM) ;Is there a macro by that name?
GO [ OUTSTR[ASCIZ/NO SUCH MACRO
*/] ;No, return
POP0J ]
PVT 1,1 ;Get vertex of body
JUMPE 1,[FATAL(BODY WITHOUT VERTEX!)] ;Nothing there!
PY 1,1
JUMPE 1,[NOTMAC: OUTSTR[ASCIZ/NOT A MACRO.
*/]↔ POP0J]
LAC 0,(1)↔ANDI 0,17
CAIE 0,$YNODE↔GO NOTMAC
YCODE 0,1↔CAIE 0,$TEXTHD↔GO NOTMAC
PTEXT 1,1 ;Text of vertex
JUMPE 1,NOTMAC↔OUTSTR[ASCIZ/<ENTERING MACRO>
/]↔ DAC 1,MACNOD
HRLI 1,000700↔DAC 1,MACPTR ;BYTE POINTER.
MOVEI 0,5*8-1↔DAC 0,MACCNT ;COUNT.
POP0J ] ;Now, return
CALL(RDNAME)
CALL(FNDNAM)
SKIPA
GO [ OUTSTR[ASCIZ/Name already in use/]
PVT 1,1 ;Get vertex of body
PTEXT 0,1
JUMPN 0,[ OUTSTR[ASCIZ/. Will edit.
/]↔ CALL(EDTEXT,1)
POP0J ]
OUTSTR[ASCIZ/ and not a macro.
*/]↔ POP0J ]
PUSHP 4↔PUSHP 5 ;Save print name
SETQ(BNEW,{MKB,WORLD}) ;Make a new body
POPP -1(1)↔POPP -2(1) ;Set print name
CALL(MKV,BNEW) ;Make a vertex
EDIT: CALL(EDTEXT,1) ;Put text on it
POP0J
DECLARE{BNEW}
ENDR NEWMAC;(TVR)----------------------------------------------------
XTEXT: ;TEXT COMMAND.
SKIPE CTRL↔GO XTAKE ;SIMULATED TAKE-A-PICTURE.
SKIPE META↔GO XSWEEP ;TRIANGULAR SWEEP
CDR 1,PDLPTR ;GET PDL POINTER
CAIGE 1,PADPDL+1↔POP0J ;IS THERE ANYTHING?, IF NOT RETURN
LAC 2,(1) ;GET ARG OFF PDL
TEST 2,VBIT↔POP0J ;MUST BE A VERTEX.
CALL(EDTEXT,2)
JCALL GEODPY
XTAKE: ;MAKE A SYNTHETIC PICTURE.
LAC 1,UNIVERSE
NWRLD 1,1
NCAMR 1,1
CALL(TAKE↑,1) ;CAMERA ARGUMENT.
JCALL GEODPY
XCONVEX: ;FORCE CONVEX FACES.
CDR 1,PDLPTR
CAIGE 1,PADPDL+1↔POP0J
LAC(1)
CALL(MKCVEX↑,0)
CALL(GEODPY)
POP0J
XREDPY: ;REDISPLAY.
CALL(STADPY)
PUSH P,DPYFLG
LAC ODPYFLG
DAC DPYFLG
CALL(GEODPY)
POP P,DPYFLG
POP0J
SUBR(EXTEND): ;"X"-EXTEND COMMANDS.
COMMENT ⊗------------------------------------------------------------
⊗
OUTSTR[ASCIZ/ COMMAND? /]
LAC 1,[POINT 6,3,17] ;SIXBIT CHARACTER TO AC3.
LACI 2,3↔ZAC 3, ;THREE CHARACTERS EXPECTED.
L1: CALL(GETCL0)
CAIE 40↔CAIN 175↔GO L2 ;TEST FOR END OF COMMAND NAME.
CAIE 12↔CAIN 15↔GO L2
CAIN "("↔JUMPG 3,L1 ;IGNORE EARLY LEFT PARENS.
CAIN "("↔GO L2
CAIL"a"↔SUBI 40 ;SUPRESS LOWER CASE.
SOJL 2,L1 ;SUPRESS EXCESS LETTERS.
SUBI 40↔IDPB 1↔GO L1 ;PACK CHARACTER INTO AC3.
;SCAN EXTENDED COMMAND JUMP TABLE FOR A MATCH.
L2: LACI 1,BEGXJT↔CDR 2,(1)
CAMN 3,2↔GO[CAR(1)↔GO@]
CAIE 1,ENDXJT↔AOJA 1,L2+1
OUTSTR[ASCIZ/ --- NO SUCH COMMAND.
*/]↔ POP0J
ENDR EXTEND;7/19/73(BGB)---------------------------------------------
;EXTENDED COMMAND JUMP TABLE.
BEGXJT: XWD XCUBE,'CUB' ;MAKE CUBIC PRISM.
XWD XCYLN,'CYL' ;MAKE CYLINDER.
XWD XBALL,'BAL' ;MAKE SPHERE.
XWD XCOLOR,'COL' ;COLORING.
ENDXJT: XWD [POP0J],0 ;EMPTY COMMAND.
XCUBE: ;MAKE CUBIC PRISM. "X-CUB".
CALL(REALIN)↔PUSH P,
CALL(REALIN)↔PUSH P,
CALL(REALIN)↔PUSH P,↔CALL(MKCUBE↑)
XXIT: LAC 2,PDLPTR↔PUSH 2,1↔DAC 2,PDLPTR ;PUSH ON GEOMED PDL.
CALL(GEODPY)↔OUTCHR["*"]↔POP0J
XCYLN:
CALL(REALIN)↔PUSH P,
CALL(REALIN)↔PUSH P,
CALL(REALIN)↔PUSH P,↔CALL(MKCYLN↑)
JCALL XXIT
XBALL:
CALL(REALIN)↔PUSH P,
CALL(REALIN)↔PUSH P,
CALL(REALIN)↔PUSH P,↔CALL(MKBALL↑)
JCALL XXIT
SUBR(XCOLOR) ;COLORING X-COMMAND.
COMMENT ⊗------------------------------------------------------------
⊗↔ ACCUMULATORS{B,F,W4,W5}
;GET ARGUMENT FROM TOP OF STACK.
CDR PTR,PDLPTR
CAIGE PTR,PADPDL+1↔POP0J
LAC B,(PTR)↔LAC F,B
TEST F,FBIT↔PFACE F,B ;FACE OR FIRST FACE.
TEST F,FBIT↔POP0J↔PUSHP F↔PUSHP B
;OLDE AND NEW VALUES.
LAC 4(F)↔DAC WORD4
LAC 5(F)↔DAC WORD5
DOM ALBEDO↔DOM RED
DOM GRN↔DOM BLU↔GO L1B
;DECODE COLORING ARGUMENTS. 00R 00B 00G 00A
L1: CALL(GETCL0)
CAIE 15↔CAIN 12↔GO L2
L1B: CALL(REALIN)
CAIN 1,"A"↔DACM ALBEDO
CAIN 1,"R"↔DACM RED
CAIN 1,"G"↔DACM GRN
CAIN 1,"B"↔DACM BLU
CAIE 1,15↔GO L1
;SETUP NEW PHOTOMETRIC PARAMETERS.
L2: SKIPGE 1,ALBEDO↔GO L2R ;ALBEDO.
FMP 1,[0.01]↔FIX 1,222000
CAILE 1,777↔LACI 1,777
DPB 1,[POINT 9,WORD4,35]
L2R: SKIPGE 1,RED↔GO L2G ;RED.
FMP 1,[0.01]↔FIX 1,222000
CAILE 1,777↔LACI 1,777
DPB 1,[POINT 9,WORD4,8]
L2G: SKIPGE 1,GRN↔GO L2B ;GREEN.
FMP 1,[0.01]↔FIX 1,222000
CAILE 1,777↔LACI 1,777
DPB 1,[POINT 9,WORD4,17]
L2B: SKIPGE 1,BLU↔GO L3 ;BLUE.
FMP 1,[0.01]↔FIX 1,222000
CAILE 1,777↔LACI 1,777
DPB 1,[POINT 9,WORD4,26]
L3: LAC W4,WORD4↔LAC W5,WORD5↔POPP B↔POPP F
L4: DAC W4,4(F)↔DAC W5,5(F)
CAMN B,F↔POP0J↔PFACE F,F
CAMN B,F↔POP0J↔GO L4
DECLARE{ALBEDO,RED,GRN,BLU,WORD4,WORD5}
ENDR XCOLOR;7/20/73(BGB)---------------------------------------------
END SA
GEOMED.FAI - EOF.